unit uPictureList;

{$mode objfpc}{$H+}

interface

uses
    BGRABitmap, contnrs, Graphics, GraphType, Controls, Classes, SysUtils,
    FileUtil;

type

    TPictureListLoadCallback = procedure(const ACount, ADone, APercent: integer;
        const AFileName, AName: string; var ABreak: boolean) of object;

    { TPictureList }

    TPictureList = class(TImageList)
    private
        function NameByFile(const AFile: string): string;
    private
        FBasePath: string;
        FNames: TFPHashList;
        FOnLoad: TPictureListLoadCallback;
        procedure SetBasePath(AValue: string);
        procedure SetOnLoad(AValue: TPictureListLoadCallback);
    protected
        procedure Init; virtual;
        procedure Done; virtual;

        procedure DoLoad(const ACount, ADone, APercent: integer; const AFileName, AName: string;
            var ABreak: boolean);
    public
        constructor Create(AOwner: TComponent); override;
        constructor CreateSize(AWidth, AHeight: integer);
        destructor Destroy; override;

        procedure Clear;

        function AddFile(const AFile, AName: string): LongInt; overload;
        function AddFile(const AFile: string): LongInt; overload;
        procedure AddPath(const APath: string; const AMask: string = '*.png';
            const AIgnoreDup: boolean = False);

        function AddBGRA(AImage: TBGRABitmap; const AName: string): LongInt;

        function IndexByName(const AName: string): LongInt;
        function NameByIndex(const AIndex: LongInt): string;
        procedure GetBitmapByName(const AName: string; Image: TCustomBitmap); overload;
        procedure GetBitmapByName(const AName: string; Image: TCustomBitmap; AEffect: TGraphicsDrawEffect); overload;

        //procedure AssignTo();

        property BasePath: string read FBasePath write SetBasePath;

        property OnLoad: TPictureListLoadCallback read FOnLoad write SetOnLoad;
    published
    end;

implementation

{ TPictureList }

function TPictureList.NameByFile(const AFile: string): string;
begin
    Result := ChangeFileExt(ExtractFileName(AFile), '');
end;

procedure TPictureList.SetBasePath(AValue: string);
begin
    if FBasePath = AValue then
        Exit;
    FBasePath := AValue;
end;

procedure TPictureList.SetOnLoad(AValue: TPictureListLoadCallback);
begin
    if FOnLoad = AValue then
        Exit;
    FOnLoad := AValue;
end;

procedure TPictureList.Init;
begin
    FNames := TFPHashList.Create;
    FBasePath := '';
end;

procedure TPictureList.Done;
begin
    FNames.Free;
end;

procedure TPictureList.DoLoad(const ACount, ADone, APercent: integer;
    const AFileName, AName: string; var ABreak: boolean);
begin
    if Assigned(FOnLoad) then
        FOnLoad(ACount, ADone, APercent, AFileName, AName, ABreak);
end;

function TPictureList.AddFile(const AFile, AName: string): LongInt;
var
    img: TBGRABitmap;
    fn: string;
begin
    // Check name
    if IndexByName(AName) > -1 then
        raise Exception.Create(Format('%S: Picture with code "%s" already exists.', [Self.Name, AName]));
    if Length(FBasePath) > 0 then
        fn := IncludeTrailingPathDelimiter(FBasePath) + AFile
    else
        fn := AFile;
    // Check file
    if not FileExists(fn) then
        raise Exception.Create(Format('%S: File "%s" not found.', [Self.Name, fn]));
    // Load image
    img := TBGRABitmap.Create(fn);
    try
        // Check dimensions and resize if needed
        if (img.Width <> Width) or (img.Height <> Height) then
            BGRAReplace(img, img.Resample(Width, Height));
        // Add image to the list
        Result := AddBGRA(img, AName);
    finally
        img.Free;
    end;
end;

function TPictureList.AddFile(const AFile: string): LongInt;
begin
    Result := AddFile(AFile, NameByFile(AFile));
end;

procedure TPictureList.AddPath(const APath: string; const AMask: string;
    const AIgnoreDup: boolean);
var
    sl: TStringList;
    c, i: LongInt;
    fn, pn: string;
    br: boolean;
begin
    //TODO Use base path
    sl := FindAllFiles(APath, AMask, False);
    try
        c := sl.Count;
        for i := 0 to c - 1 do
        begin
            fn := sl[i];
            pn := NameByFile(fn);
            br := False;
            DoLoad(c, i, (i * 100) div c, fn, pn, br);
            if br then
                Break;
            AddFile(fn, pn);
            DoLoad(c, i + 1, (succ(i) * 100) div c, fn, pn, br);
        end;
    finally
        sl.Free;
    end;
end;

function TPictureList.AddBGRA(AImage: TBGRABitmap; const AName: string
    ): LongInt;
begin
    Result := AddMasked(AImage.Bitmap, TColor(0));
    FNames.Add(AName, Pointer(Result + 1));
end;

constructor TPictureList.Create(AOwner: TComponent);
begin
    inherited Create(AOwner);

    Init;
end;

constructor TPictureList.CreateSize(AWidth, AHeight: integer);
begin
    inherited CreateSize(AWidth, AHeight);

    Init;
end;

destructor TPictureList.Destroy;
begin
    Done;

    inherited Destroy;
end;

procedure TPictureList.Clear;
begin
    inherited;
    FNames.Clear;
end;

function TPictureList.IndexByName(const AName: string): LongInt;
begin
    Result := Cardinal(FNames.Find(AName)) - 1;
end;

function TPictureList.NameByIndex(const AIndex: LongInt): string;
var
    i: LongInt;
begin
    Result := '';
    for i := 0 to FNames.Count - 1 do
    begin
        if AIndex = (LongInt(FNames[i]) - 1) then
        begin
            Result := FNames.NameOfIndex(i);
            Break;
        end;
    end;
end;

procedure TPictureList.GetBitmapByName(const AName: string; Image: TCustomBitmap);
begin
    GetBitmap(IndexByName(AName), Image);
end;

procedure TPictureList.GetBitmapByName(const AName: string; Image: TCustomBitmap; AEffect: TGraphicsDrawEffect);
begin
    GetBitmap(IndexByName(AName), Image, AEffect);
end;

end.


